This approach was taken after looking at designs for a linear programming solution proved to be too costly for initial set up.
So, this approach for a Monte Carlo simulation was picked for ease of set up at the expense of processing time.
We are going to set up the data to have a monthly increase field and then calculate the new returns. The second returns will currently be just an increase of 84 months.
Now, lets pull in the data and clean it up:
# Review imported Data
head(Data)## UnitNumber LeaseEnd Term LeaseEndDate
## 1 08N107 1/1/2022 60 2022-01-01
## 2 08N829 3/1/2021 84 2021-03-01
## 3 08N108 12/31/2021 60 2021-12-31
## 4 08N109 1/1/2022 60 2022-01-01
## 5 08N110 1/1/2022 60 2022-01-01
## 6 08N111 1/1/2022 60 2022-01-01# Standardize End of Lease -- Some leases have end of lease date as the 30th/31st, this puts all units on the 1st
Data = Data %>%
mutate(
FirstOfMonth = floor_date(LeaseEndDate, "month")
,LeaseEndFix = if_else(FirstOfMonth == LeaseEndDate
,LeaseEndDate
,LeaseEndDate + 1
)
)
# Holding place to adjust
Data$DateIncrease = 0
# End result method check
Data$NewEnd = Data$LeaseEndFix %m+% months(Data$DateIncrease)
# New lease to replace -- Holding place is all 7-year leases
Data$NewLease = 84
Data$SecondEnd = Data$NewEnd %m+% months(Data$NewLease)
# Base level variance
BaseLevel = var(table(Data$SecondEnd))
# Cycle review
plot_ly(alpha = .6) %>%
add_histogram(x = Data$LeaseEndFix, name = "First Returns") %>%
add_histogram(x = Data$SecondEnd, name = "Second Returns") %>%
layout(barmode = "overlay")## Warning: `arrange_()` is deprecated as of dplyr 0.7.0.
## Please use `arrange()` instead.
## See vignette('programming') for more help
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.This section will setup controls for the simulations for all models for easier control in testing and publish runs
# Number of Sims
nSims = 1000Now, lets look at the most optional model to maximize smoothness. We will follow here with the bulleted specs of the model and the code.
All following models will hide the code since it will be the same structure with changes to the sampling functions.
The trigger we will pull are:
# Initialize Best Run variable
BestRunModel1 = 500000
# Define random addition for number of months to hold lease for simulation
ExtensionReturns = function(x){
ifelse(x == 0
,sample(c(0:6), 1, replace = TRUE, prob = c(.50,rep(1/6*.50, 6))) #Input will be 84-84 to be a zero
,sample(c(0,1:x), 1, replace = TRUE, prob = c(.50,rep(1/x*.50, x))) #Input will be 84-x, where x is <84 so it will be >1 response
)
}
# Define new lease replacement
ExtensionNewLease = function(x){
# Lease Options: 60, 66, 72, 78, 84
# We'll try to keep the options low, so .05 for each besides 84
sample(c(60, 66, 72, 78, 84), 1, replace = TRUE, prob = c(.05,.05,.05,.05,.8))
}
# define process for adding months and determining variance
SimRun = function(){
x = Data
x = x %>%
rowwise() %>%
mutate(DateIncrease = ExtensionReturns((84-Term)) # Turn-in extension
,NewLease = ExtensionNewLease() # Replacement leases
)
# Determine new date to turn in leases
x$NewEnd = x$LeaseEndFix %m+% months(x$DateIncrease)
# Determine end date for new leases
x$SecondEnd = x$NewEnd %m+% months(x$NewLease)
#
a = var(table(x$SecondEnd))
if(a < BestRunModel1){
return(x)
}
}
for(i in 1:nSims){
y = SimRun()
if(length(y) > 0){
DataModel1 = y
BestRunModel1 = var(table(DataModel1$SecondEnd))
}
}
# Cycle review
plot_ly(alpha = .6) %>%
add_histogram(x = Data$SecondEnd, name = "Second Returns") %>%
add_histogram(x = DataModel1$SecondEnd, name = "Model 1") %>%
layout(barmode = "overlay"
,xaxis = list(type = "date"
,tickformat = "%B %Y")
,legend = list(x = .6, y = 1))The trigger we will pull are:
The trigger we will pull are:
The trigger we will pull are:
The trigger we will pull are:
The trigger we will pull are:
This is a full optimization model, just to see what it would look like to get as smooth of a 2nd wave of lease swaps as possible
Finally, a check on the different model’s variances and compare all models together by month.
# Clean up all data in monthly count and reminder description
BaseTable = as.data.frame(table(Data$SecondEnd))
# 50% 0 Weight, Extensions 20% 6-month segment leases
Model1Table = as.data.frame(table(DataModel1$SecondEnd))
# 25% 0 Weight, Extensions 40% 6-month segment leases
Model2Table = as.data.frame(table(DataModel2$SecondEnd))
# No 0 Weight, Extensions 40% 6-month segment leases
Model3Table = as.data.frame(table(DataModel3$SecondEnd))
# No Weight, Extensions 40% shorter variable leases
Model4Table = as.data.frame(table(DataModel4$SecondEnd))
# No 0 Weight, Extensions 100% 6-month segment leases
Model5Table = as.data.frame(table(DataModel5$SecondEnd))
# No 0 Weight, Extensions 100% variable leases
Model6Table = as.data.frame(table(DataModel6$SecondEnd))
# Fully variable
Model7Table = as.data.frame(table(DataModel7$SecondEnd))## ModelName Results
## 1: Baseline 303.04440
## 2: Model 1 106.31008
## 3: Model 2 75.68671
## 4: Model 3 83.30886
## 5: Model 4 87.95294
## 6: Model 5 70.39219
## 7: Model 6 70.24132
## 8: Model 7 27.72498